home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / comp / primops / splow.t < prev    next >
Encoding:
Text File  |  1989-07-05  |  7.4 KB  |  217 lines
  1. (herald splow
  2.   (env (*value orbit-env 'base-early-binding-env) constants primops arith locations))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27.  
  28. (define-constant (return . args) 
  29.   (ignore args)
  30.   (lap ()                           
  31.     (jr link-reg)
  32.     (sub nargs zero nargs)))
  33.  
  34. (declare simplifier return simplify-values)
  35. #|
  36. (define-constant (receive-values recipient thunk) 
  37.   (ignore recipient thunk)
  38.   (lap ()
  39.     (save ($ -64) sp sp)
  40.     (move A1 S0)                       ; push "recipient"
  41.     (move A2 P)                      ; prepare to call thunk
  42.     (move ($ 1) NARGS)               ; thunk takes no arguments
  43.     (load l (d@nil slink/icall) extra)
  44.     (jalr (d@r extra 0))
  45.     (add ($ template/return-offset) link-reg)
  46.     (template 0 -1 t)
  47.     (sub nargs zero %i4)              ; !!we are saved so nargs is %i4
  48.     (move S0 P)              ; prepare to call recipient
  49.     (restore)            ; restore continuation
  50.     (load l (d@nil slink/icall) extra)
  51.     (jr (d@r extra 0))
  52.     (noop)))
  53. |#
  54.  
  55. (define-constant (receive-values recipient thunk) 
  56.   (ignore recipient thunk)
  57.   (lap ()
  58.     (sub ($ 8) sp)
  59.     (store l link-reg (d@r sp 4))
  60.     (store l A1 (d@r sp 0))                       ; push "recipient"
  61.     (move A2 P)                      ; prepare to call thunk
  62.     (move ($ 1) NARGS)               ; thunk takes no arguments
  63.     (load l (d@nil slink/icall) extra)
  64.     (jalr extra)
  65.     (add ($ template-return-offset) link-reg)
  66.     (template 1 -1 t)
  67.     (load l (d@r SP 0) P)              ; prepare to call recipient
  68.     (load l (d@r sp 4) link-reg)
  69.     (add ($ 8) SP)            ; restore continuation
  70.     (load l (d@nil slink/icall) extra)
  71.     (jr extra)
  72.     (sub NARGS zero NARGS)))
  73.  
  74. (declare simplifier receive-values simplify-receive-values)
  75.  
  76. (define-constant make-pointer        ; extend and number of bytes
  77.   (primop make-pointer ()                                        
  78.     ((primop.generate self node)
  79.      (generate-make-pointer node))
  80.     ((primop.type self node)
  81.      '#[type (proc #f (proc #f top) top fixnum)])))
  82. ;     '#[type (proc #f (proc #f top) extend fixnum)])))
  83.  
  84.  
  85. (define-constant slink-ref
  86.   (primop slink-ref ()
  87.     ((primop.generate self node)
  88.      (generate-slink-ref node))))
  89.  
  90. (define-constant set-slink-ref
  91.   (primop set-slink-ref ()
  92.     ((primop.side-effects? self) t)
  93.     ((primop.generate self node)
  94.      (generate-set-slink-ref node))))
  95.  
  96. (define-constant system-global
  97.   (object (lambda (i) (slink-ref i))
  98.     ((setter self)
  99.      (lambda (i val) (set-slink-ref i val)))))
  100.  
  101.  
  102.  
  103. ;; template junk, see template.doc
  104.  
  105. (define-constant template-enclosing-object
  106.   (primop template-enclosing-object ()
  107.     ((primop.generate self node)
  108.      (generate-template-enclosing-object node))
  109.     ((primop.type self node)
  110.      '#[type (proc #f (proc #f top) template)])))
  111.  
  112. (define-constant gc-extend->pair
  113.   (primop gc-extend->pair ()
  114.     ((primop.generate self node)
  115.      (generate-one-arg node (lambda (acc t-reg)
  116.                   (emit risc/add (machine-num 1) acc t-reg))))
  117.     ((primop.type self node)
  118.      '#[type (proc #f (proc #f top) top)])))
  119. ;     '#[type (proc #f (proc #f pair) extend)])))
  120.  
  121. (define-constant gc-pair->extend
  122.   (primop gc-pair->extend ()
  123.     ((primop.generate self node)
  124.      (generate-one-arg node (lambda (acc t-reg)
  125.                   (emit risc/sub (machine-num 1) acc t-reg))))
  126.     ((primop.type self node)
  127.      '#[type (proc #f (proc #f top) top)])))
  128. ;     '#[type (proc #f (proc #f extend) pair)])))
  129.     
  130. (define-constant closure-enclosing-object
  131.   (primop closure-enclosing-object ()
  132.     ((primop.generate self node)
  133.      (generate-closure-enclosing-object node))
  134.     ((primop.type self node)
  135.      '#[type (proc #f (proc #f top) top)])))
  136. ;     '#[type (proc #f (proc #f top) extend)])))
  137.  
  138. (define-constant frame-header
  139.   (primop frame-header ()
  140.     ((primop.generate self node)
  141.      (generate-frame-header node))))
  142.  
  143. (define-constant frame-sp
  144.   (primop frame-sp ()
  145.     ((primop.generate self node)
  146.      (generate-frame-sp node))))
  147.  
  148. (define-constant stack-pointer
  149.   (primop stack-pointer ()
  150.     ((primop.generate self node)
  151.      (generate-stack-pointer node))))
  152.  
  153. ; see template.doc
  154.                                                     
  155. (define-constant (bit-test operand bit)    ; true if bit is on
  156.   (if (fixnum-equal? (fixnum-logand operand (fixnum-ashl 1 bit)) 0)
  157.       '#f
  158.       '#t))
  159.  
  160. (define-constant (template-internal-bit? tem)          
  161.   (let ((tem (if (fixnum-equal? (template-nargs tem) 0)
  162.                  (extend-pointer-elt tem 0)
  163.                  tem)))
  164.     (bit-test (mref-16-u tem (fixnum-add -2 template/annotation)) 0)))
  165.  
  166. (define-constant (template-superior-bit? tem) '#f)
  167.                                     
  168. (define-constant (template-nary? tem)
  169.   (alt-bit-set? tem))
  170.  
  171. (define-constant (template-pointer-slots tem)
  172.   (mref-16-u tem (fixnum-add -2 template/pointer)))
  173.  
  174. (define-constant (template-scratch-slots tem) 0)
  175.  
  176. (define-constant (template-nargs tem)
  177.   (mref-8-s tem (fixnum-add -2 template/nargs)))
  178.  
  179. (define-constant (template-encloser-offset template)
  180.   (fixnum-ashr (mref-integer template (fixnum-add -2 template/offset)) 2))
  181.  
  182. (define-constant (template-handler-offset template)
  183.   (mref-16-u template (fixnum-add -2 template/handler)))
  184.  
  185. (define-constant (closure-encloser-offset closure)
  186.   (fixnum-ashr (mref-16-u (extend-header closure) (fixnum-add -2 template/pointer)) 2))
  187.  
  188. (define-constant (unit-top-level-forms unit)
  189.   (make-pointer unit 3))
  190.  
  191. (define-constant (alt-bit-set? extend)            ; if bit 7 of header is on
  192.   (fixnum-less? (mref-8-s extend (fixnum-add -2 template/header)) 0))
  193.  
  194. (define-constant (set-alt-bit! x)
  195.   (modify (mref-8-u x (fixnum-add -2 template/header))
  196.       (lambda (x) (fixnum-logior #b10000000 x))))
  197.  
  198. (define-constant (clear-alt-bit! x)
  199.   (modify (mref-8-u x (fixnum-add -2 template/header))
  200.       (lambda (x) (fixnum-logand #b01111111 x))))
  201.  
  202.  
  203. (define-constant vcell-defined? alt-bit-set?)
  204.  
  205. (define-constant set-vcell-defined set-alt-bit!)
  206.  
  207. (define-constant set-vcell-undefined clear-alt-bit!)
  208.  
  209. (define-constant pure? alt-bit-set?)
  210.  
  211. (define-constant (purify! x)
  212.   (set-alt-bit! x)
  213.   (return))
  214.                        
  215.  
  216.  
  217.